home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / undefine.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  7.1 KB  |  202 lines  |  [TEXT/CCL2]
  1. ;;; -*- Package: CL-USER -*-
  2.  
  3. (in-package "CL-USER")
  4.  
  5. #|
  6. undefine.lisp
  7. Commands for undefining variables, functions, and methods 
  8. defined at the top level.
  9.  
  10. Please send improvements.
  11.  
  12. Daniel LaLiberte
  13. NCSA
  14. liberte@ncsa.uiuc.edu
  15. |#
  16.  
  17. (defparameter *prompt-to-undefine* nil)
  18. (defparameter *offer-to-delete-definition* nil)
  19.  
  20.  
  21. ;;#################################################################
  22. ;; Some general utilities extracted from Carl's code.  liberte
  23.  
  24. (defun buffer-top-level-sexp-bounds (buffer)
  25.   "Return the top-level sexp bounds, or nil if there is none.
  26. The top level sexp starts with left paren in the first column.
  27. The current position may be just before the left paren, 
  28. or before the next top-level sexp."
  29.   (let* ((sexp-start-string #.(format nil "~%("))
  30.          (top-level-sexp-start
  31.           (if (and (= (buffer-column buffer) 0)
  32.                      (char-equal (buffer-char buffer) #\()) ;; looking at \(            (buffer-position buffer)
  33.             (buffer-position buffer)
  34.             (let ((foo (buffer-string-pos buffer sexp-start-string :from-end t)))
  35.               (and foo (+ foo 1))))))
  36.     (if (null top-level-sexp-start)
  37.       nil
  38.       (multiple-value-bind (sexp-start sexp-end)
  39.                            (buffer-current-sexp-bounds buffer top-level-sexp-start)
  40.         (if (null sexp-start)
  41.           nil
  42.           (values sexp-start sexp-end))
  43.         ))))
  44.  
  45. (defun buffer-top-level-sexp (buffer)
  46.   "Return the top-level sexp or nil if none."
  47.   (let ((start (buffer-top-level-sexp-bounds buffer)))
  48.     (if start
  49.       (buffer-current-sexp buffer start)
  50.       nil)))
  51.  
  52. #|#################################################################
  53. From: "Carl L. Gay" <cgay@skinner.cs.uoregon.edu>
  54.  
  55. [Modified to:
  56.   - use buffer-top-level-sexp-bounds
  57.   - call Steve Miner's undefmethod
  58.  liberte]
  59.  
  60. |#
  61. ;;; ________________________________________
  62. ;;; Kill Definition 
  63.  
  64. ;;; Find the definition under the cursor, determine if it's killable, if so
  65. ;;; prompt the user, kill the definition, and then optionally remove the
  66. ;;; definition from the buffer (or comment it out?)
  67.  
  68. (defmethod ed-undefine ((w fred-window))
  69.   (flet ((set-minibuffer (&rest args) (ed-beep) (apply 'set-mini-buffer w args)))
  70.     ;; error exit might be better
  71.     (let* ((buffer (fred-buffer w))
  72.            (sexp-start (buffer-top-level-sexp-bounds buffer))
  73.            (sexp (buffer-current-sexp buffer sexp-start))
  74.            (defining-form nil)
  75.            (undefine-fun nil))
  76.       (if (or (atom sexp)
  77.               (not (atom (setq defining-form (car sexp))))
  78.               (not (setq undefine-fun (get (car sexp) 'undefine))))
  79.         (set-minibuffer "Don't know how to undefine ~A."
  80.                         (if defining-form (format nil "a ~A" defining-form) sexp))
  81.         (let ((definition-name (second sexp)))
  82.           (catch-cancel
  83.             (when (or (null *prompt-to-undefine*)
  84.                       (y-or-n-dialog (format nil "Undefine ~S ~S?"
  85.                                              defining-form definition-name)))
  86.               (format t "un-~s: ~A~%" defining-form 
  87.                       (apply undefine-fun (cdr sexp))))
  88.             (when (and *offer-to-delete-definition*
  89.                        (y-or-n-dialog (format nil "Remove definition of ~S ~S from buffer?"
  90.                                               defining-form definition-name)))
  91.               (multiple-value-bind (sexp-start sexp-end)
  92.                                    (buffer-current-sexp-bounds buffer sexp-start)
  93.                 (buffer-delete buffer sexp-start sexp-end))
  94.               )))))))
  95.  
  96. ;;(comtab-set-key *control-x-comtab* '(:control :meta #\d) 'ed-undefine)
  97.   (def-fred-command (:control #\z) ed-undefine)
  98.  
  99. (defun undefine-variable (symbol &rest qlb)
  100.   (declare (ignore qlb))
  101.   (if (boundp symbol)
  102.     (makunbound symbol)))
  103.  
  104. (defun undefine-defun (symbol &rest qlb)
  105.   (declare (ignore qlb))
  106.   (if (fboundp symbol)
  107.     (fmakunbound symbol)))
  108.  
  109. (defun undefine-defmethod (symbol &rest qlb)
  110.   (if (fboundp symbol)
  111.     (eval `(undefmethod ,symbol ,@qlb))))
  112.  
  113. (dolist (foo '(defvar defparameter defconstant))
  114.   (setf (get foo 'undefine) 'undefine-variable))
  115.  
  116. (setf (get 'defun 'undefine) 'undefine-defun)
  117. (setf (get 'defmacro 'undefine) 'undefine-defun)
  118. (setf (get 'defmethod 'undefine) 'undefine-defmethod)
  119.  
  120.  
  121. #|#################################################################
  122. The following is for undefining methods only.
  123. From: Steve Miner
  124.  PW Tech Centre
  125.  miner@tc.pw.com
  126. [Modified ed-undefmethod to look for top-level sexp. - liberte]
  127. |#
  128.  
  129. (defun remove-lambda-keywords (lambda-list)
  130.   (cond ((endp lambda-list) nil)
  131.         ((member (car lambda-list) lambda-list-keywords :test #'eq)
  132.      nil)
  133.         (t (cons (car lambda-list) (remove-lambda-keywords 
  134.                                     (cdr lambda-list))))))
  135.  
  136.  
  137. (defun class-list-spec (lambda-list)
  138.   (mapcar #'(lambda (arg) (cond ((symbolp arg) '(find-class 't))
  139.                                 ((symbolp (cadr arg)) `(find-class
  140.                             ',(cadr arg)))
  141.                                 ((eq (caadr arg) 'eql) `(list 'eql
  142.                              ,(cadadr
  143.                                arg)))
  144.                                 (t (error "Malformed lambda-list ~S."
  145.                       lambda-list))))
  146.           (remove-lambda-keywords lambda-list)))
  147.  
  148. ;;; NOTE: the order of the method qualifiers is significant so the
  149. ;;; NREVERSE is necessary.
  150. (defun get-lambda-and-quals (qlb)
  151.   "Returns multiple values, the lambda-list and the list of method
  152. qualifiers, from the QLB which is a list of method qualifiers, a
  153. lambda list and a body (essentially the method definition without the 
  154. DEFMETHOD or the method name -- the CDDR of the method definition if
  155. you will.)"
  156.   (let ((quals nil))
  157.     (dolist (x qlb)
  158.       (if (listp x)
  159.       (return (values x (nreverse quals)))
  160.       (push x quals)))))
  161.  
  162.  
  163.  
  164. (defmacro undefmethod (name &rest qlb)
  165.   "Removes method that is specified using the same syntax as
  166. DEFMETHOD.  The body is ignored.
  167. With this macro, you could just change your defmethod to undefmethod, 
  168. and evaluate it to undefine it.
  169. BUG: if NAME has no symbol-function, an error results."
  170.   ;; QLB could be qualifier, lambda list, and body.  We'll end up
  171.   ;; ignoring the body
  172.   (multiple-value-bind (lambda-list quals) (get-lambda-and-quals qlb)
  173.     `(let* ((func (symbol-function ',name))
  174.             (meth (find-method func ',quals 
  175.                                (list ,@(class-list-spec lambda-list))
  176.                    nil)))
  177.        (when meth
  178.          (remove-method func meth)
  179.          (values meth :undefmethod)))))
  180.  
  181.  
  182. (defmacro find-defmethod (name &rest qlb)
  183.   "Finds method that is specified using the same syntax as DEFMETHOD.
  184. The body is ignored."
  185.   ;; QLB could be qualifier, lambda list, and body.  We'll end up
  186.   ;; ignoring the body
  187.   (multiple-value-bind (lambda-list quals) (get-lambda-and-quals qlb)
  188.     `(find-method (symbol-function ',name) ',quals 
  189.                   (list ,@(class-list-spec lambda-list)) nil)))
  190.  
  191.  
  192. ;;; Bind this to a Fred Key
  193. (defmethod ed-undefmethod ((w fred-window))
  194.   "Undefine the method defined by the surrounding defmethod."
  195.   (let ((sexp (buffer-top-level-sexp (fred-buffer w))))
  196.     (if (and sexp (eq (car sexp) 'defmethod))
  197.       (format t "undefmethod ~A~%" (eval (cons 'undefmethod (cdr sexp))))
  198.       (ed-beep))))
  199.  
  200. ;For example,
  201. ;  (def-fred-command (:control #\z) ed-undefmethod)
  202.